home *** CD-ROM | disk | FTP | other *** search
/ Chip 2004 November / CHIP_CD_2004-11.iso / software / timesentry / timesentry.exe / {app} / SetTime.vbs < prev    next >
Encoding:
Text File  |  2004-04-26  |  4.6 KB  |  159 lines
  1. 'SetTime2.vbs - Adjusts system time if off by 1 second or more.
  2. '⌐ Bill James - wgjames@mvps.org - September 02, 2000
  3. 'Credit to Michael Harris for original concept.
  4. 'Revised 9 Apr 2002
  5. '   Added error trap for time server being unavailable
  6. '   Added backup time server (NIST)
  7.  
  8. Option Explicit
  9. Dim ws, strTitle
  10. Set ws = CreateObject("WScript.Shell")
  11. strTitle = "TimeKeeper"
  12.  
  13. 'Check system compatibility.
  14. Dim http
  15. Call ChkCompat
  16.  
  17. 'Read time zone offset hex value from Registry.
  18. Dim TimeOffset, HexVal
  19. TimeOffset = ws.RegRead("HKLM\SYSTEM\CurrentControlSet\" & _
  20.              "Control\TimeZoneInformation\ActiveTimeBias")
  21. 'Reg value format varies between Win9x and NT
  22. If IsArray(TimeOffset) Then
  23.   'Win9x uses a reversed 4 element array of Hex values.
  24.   HexVal = Hex(TimeOffset(3)) & Hex(TimeOffset(2)) & _
  25.            Hex(TimeOffset(1)) & Hex(TimeOffset(0))
  26. Else 'Must be a NT system.
  27.   HexVal = Hex(TimeOffset)
  28. End If
  29.  
  30. 'Convert to minutes of time zone offset.
  31. TimeOffset = - CLng("&H" & HexVal)
  32.  
  33. 'Get time from server.  Recheck up to 5 times if lagged.
  34. Dim n, timechk, localdate, lag, gmttime
  35. Dim timeserv
  36.  
  37. 'Check primary server, US Naval Observatory
  38. timeserv = "http://tycho.usno.navy.mil/cgi-bin/timer.pl"& now()
  39. http.open "GET",timeserv,false
  40. On Error Resume Next
  41. http.send
  42. If Err Then
  43.   'Use backup server, National Institute of Standards and Technology (NIST)
  44.   timeserv = "http://www.nist.gov/"
  45.   err.Clear
  46. End If
  47. On Error GoTo 0
  48.  
  49. For n = 0 to 4
  50.   http.open "GET",timeserv,false
  51.   'Check response time to avoid invalid errors.
  52.   timechk = Now
  53.   On Error Resume Next
  54.   http.send
  55.   If Err Then
  56.     If Err =  -2146697211 Then
  57.       MsgBox "Both Time Servers unavailable!"
  58.     Else
  59.       MsgBox "Unknown Error occurred, " & Err
  60.     End If
  61.     Wscript.Quit
  62.   End If
  63.   On Error GoTo 0
  64.   localdate = Now
  65.   lag = DateDiff("s", timechk, localdate)
  66.  
  67.   'Key concept for script is reading header date.
  68.   gmttime = http.getResponseHeader("Date")
  69.  
  70.   'Trim results to valid date format.
  71.   gmttime = right(gmttime, len(gmttime) - 5)
  72.   gmttime = left(gmttime, len(gmttime) - 3)
  73.  
  74.   'If less than 2 seconds lag we can use the results.
  75.   If lag < 2 Then Exit For
  76. Next
  77.  
  78. 'If still too much lag after 5 attemps, quit.
  79. If n = 4 then
  80.   ws.Popup "Unable to establish a reliable connection " & _
  81.            "with time server.  This could be due to the " & _
  82.            "time server being too busy, your connection " & _
  83.            "already in use, or a poor connection." & vbcrlf & _
  84.            vbcrlf & "Please try again later.", 5, strTitle
  85.   Cleanup
  86. End If
  87.  
  88. 'Time and date error calculations.
  89. Dim remotedate, diff, newnow, newdate, newtime, ddiff, sdiff
  90.  
  91. 'Add local time zone offset to GMT returned from USNO server.
  92. remotedate = DateAdd("n", timeoffset, gmttime)
  93.  
  94. 'Calculate seconds difference betweed remote and local.
  95. diff = DateDiff("s", localdate, remotedate)
  96.  
  97. 'Adjust for difference and lag to get actual time.
  98. newnow = DateAdd("s", diff + lag, now)
  99.  
  100. 'Split out date and calculate any difference.
  101. newdate = FormatDateTime(DateValue(newnow))
  102. ddiff = DateDiff("d", Date, newdate)
  103.  
  104. 'Split out time.
  105. newtime = TimeValue(newnow)
  106.  
  107. 'Convert time to 24 hr format required for OS compatibility.
  108. newtime = Right(0 & Hour(newtime), 2) & ":" & _
  109.           Right(0 & Minute(newtime), 2) & ":" & _
  110.           Right(0 & Second(newtime), 2)
  111.  
  112. 'Calculate time difference.
  113. sdiff = DateDiff("s", time, newtime)
  114.  
  115. 'If off by 1 or more seconds, adjust local time
  116. Dim tmsg
  117. If sdiff < 2 and sdiff > -2 Then
  118.   tmsg = "System is accurate to within " & _
  119.     "1 second.  System time not changed."
  120. Else
  121.   'Run DOS Time command in hidden window.
  122.   ws.Run "%comspec% /c time " & newtime, 0
  123.   tmsg = "System time off by " & sdiff & _
  124.          " seconds.  System time changed to " & _
  125.          CDate(newtime)
  126. End If
  127.  
  128. 'If date off, change it.
  129. Dim dmsg
  130. If ddiff <> 0 Then
  131.   ws.Run "%comspec% /c date " & newdate, 0
  132.   dmsg = "Date off by " & ddiff & " days.  System date changed " & _
  133.          "to " & FormatDateTime(newdate,1) & vbcrlf & vbcrlf
  134. End If
  135.  
  136. 'Show the changes
  137. ws.Popup "Time syncronizion using " & timeserv & vbcrlf & _
  138.           vbcrlf & dmsg & tmsg, 5, strTitle, 4096
  139.  
  140. Call Cleanup
  141.  
  142. Sub ChkCompat
  143.   On Error Resume Next
  144.   Set http = CreateObject("microsoft.xmlhttp")
  145.   If Err.Number <> 0 Then
  146.     ws.Popup "Process Aborted!" & vbcrlf & vbcrlf & _
  147.              "Minimum system requirements to run this " & _
  148.              "script are Windows 95 or Windows NT 4.0 " & _
  149.              "with Internet Explorer 5.", , strTitle
  150.     Cleanup
  151.   End If
  152. End Sub
  153.  
  154. Sub Cleanup
  155.   Set ws = Nothing
  156.   Set http = Nothing
  157.   WScript.Quit
  158. End Sub
  159.